--
-- Implementation of Johnston clique finding algorithm.
--
-- Author:  Nikita Afanasenko <nikita@afanasenko.name>
-- License: GPL
--

module Clique.Johnston where

import Data.Set as S
import Data.Graph.Inductive.Tree(UGr)
import Data.Graph.Inductive.Graph(neighbors,nodes,Node)

--
-- Functions for calculation of nodes set to process at each step of
-- the algorithm
--
basicCalc :: Set Node -> Set Node -> UGr -> Set Node
basicCalc possible _ _ = possible

-- In practice this function shows the best time result for reasonable graphs.
-- Algorithm guarantee that intersection will never be empty
simpBronKerbCalc :: Set Node -> Set Node -> UGr -> Set Node
simpBronKerbCalc possible intersection g =
  possible S.\\ (S.fromList $ neighbors g $ head $ S.elems intersection)

-- The goal of this function is to reduse the number of elements of
-- nodes set, which we'll process at each step of algorithm
genBronKerbCalc :: Int -> Set Node -> Set Node -> UGr -> Set Node
genBronKerbCalc threshold possible intersection g  =
  loop intersection 0 S.empty
  where
    loop t sizeOfSet s
      | S.null t = s
      | sizeOfSet <= threshold && sizeOfSet /= 0 = s
      | otherwise = -- Iterate loop
        let
          j = head $ S.elems t
          nextSet = possible S.\\ (S.fromList $ neighbors g j)
          nextSizeOfSet = S.size nextSet
        in
          if nextSizeOfSet < sizeOfSet || sizeOfSet == 0
          then loop (S.delete j t) nextSizeOfSet nextSet
          else loop (S.delete j t) sizeOfSet s

--
-- Implementation of Johnston algorithm parametrized by the function for
-- calculation of nodes set to process at each step of the algorithm
--
johnstonAlgorithm ::
  UGr ->
  (Set Node -> Set Node -> UGr -> Set Node) ->
  (Set Node, Int)
johnstonAlgorithm g calcSetToProcess =
  case nodes g of
    [] -> (S.empty, 0)
    vs ->
      (maxclique, cliquesnum)
      where
      initialVs = S.fromList vs
      (cliquesnum, (maxclique, _)) =
        expand S.empty initialVs initialVs (0, (S.empty, 0))
  where
    expand
      combination intersection possible
      -- We use maxcliquesize variable to decrease the number of
      -- size calculating function applications
      c@(cliquesnum, (maxclique, maxcliquesize))
      -- Intersection is empty, so we've found clique.
      -- Increase counter and choose maximal
      | S.size intersection == 0 && S.size combination >= maxcliquesize =
        (cliquesnum + 1, (combination, S.size combination))
      | S.size intersection == 0 =
        (cliquesnum + 1, (maxclique, maxcliquesize))
      | otherwise =
        -- Start loop
        loop s possible c
        where
          s = calcSetToProcess possible intersection g
          loop s possible cliqueTuple
            | S.null s = cliqueTuple
            | otherwise =
              -- Iterate loop
              loop nextS nextPossible nextCliqueTuple
              where
                i = head $ S.elems s
                nextS = S.delete i s
                nextPossible = S.delete i possible
                nextCliqueTuple =
                  let gi = S.fromList $ neighbors g i in
                  expand
                    (S.insert i combination)
                    (S.intersection gi intersection)
                    (S.intersection gi nextPossible)
                    cliqueTuple

--
-- Maximal clique finding functions with different methods of calculation
-- of nodes set to process at each step of the algorithm
--
maxCliqueBasic :: UGr -> (Set Node, Int)
maxCliqueBasic g =
  johnstonAlgorithm g basicCalc

maxCliqueSimplifiedBronKerb :: UGr -> (Set Node, Int)
maxCliqueSimplifiedBronKerb g =
  johnstonAlgorithm g simpBronKerbCalc

maxCliqueGenBronKerb :: UGr -> (Set Node, Int)
maxCliqueGenBronKerb g =
  johnstonAlgorithm g $ genBronKerbCalc 3

maxClique :: UGr -> (Set Node, Int)
maxClique = maxCliqueSimplifiedBronKerb
